with Ada.Unchecked_Conversion;
with Ada.Exceptions;
with Interfaces.C;
with Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants;

package body win32api_interface.process.helper is

  ----------
  -- Kill --
  ----------

  procedure Kill (PName : in String) is
    hProc : Handle;
    ID    : Process_ID;
  begin
    ID := Find(PName);
    hProc := Open_Process(ID);
    Terminate_Process(hProc);
    Close_Handle(hProc);
  end Kill;

  --------------
  -- Kill_All --
  --------------

  function Kill_All (PName : in String) return Integer is
    hProc: Handle;
    PIDs: constant Process_ID_array := Find_All(PName);
  begin
    for i in PIDs'Range loop
      hProc := Open_Process(PIDs(i));
      Terminate_Process(hProc);
      Close_Handle(hProc);
    end loop;
    Return PIDs'Last;
  end Kill_All;

  ------------
  -- Launch --
  ------------

  function Launch (Path : in String) return Process_ID is

    function directory_of (filepath : in String) return String is
      lastpos : integer;

      function cut (s: string; n: integer) return string is
        s2: string(1..n);
      begin
        for i in 1..n loop
          s2(i) := s(i);
        end loop;
        return s2;
      end cut;

    begin
      for i in 1..filepath'last loop
        if filepath(i) = '\' then lastpos := i; end if;
      end loop;
      Return cut(filepath, lastpos);
    end directory_of;

  begin
    Return Create_Process(Path, directory_of(Path));
  end Launch;

  ----------
  -- Find --
  ----------

  procedure Find (PName : in String;
                  Result : out Process_ID;
                  Valid : out Boolean) is
    PIDs : constant Process_ID_Array := Find_All_Process_IDs;

    Find_Procedure_Error : exception;

    Upper_Case_Name : constant String
      := Ada.Strings.Fixed.Translate(PName,
                                     Ada.Strings.Maps.Constants.Upper_Case_Map);
  begin
    --  We enumerate all PIDs on the system, obtain the name for each
    --  process, and compare it with the requested process name.
    Valid := False;
    for i in PIDs'Range loop
      if Ada.Strings.Fixed.Translate (Get_Process_Name (PIDs (i)),
                                      Ada.Strings.Maps.Constants.Upper_Case_Map)
         = Upper_Case_Name
        then
          Result := PIDs (i); Valid := True; exit;
      end if;
    end loop;
    if not Valid then
      Ada.Exceptions.Raise_Exception(Find_Procedure_Error'Identity,
                                     "Process "&PName&" not found.");
    end if;
  end Find;

  ----------
  -- Find --
  ----------

  function Find (PName : in String) return Process_ID is
    Valid : Boolean;
    Result : Process_ID;
    PIDs : constant Process_ID_Array := Find_All_Process_IDs;

    Find_Function_Error : exception;

    Upper_Case_Name : constant String
      := Ada.Strings.Fixed.Translate(PName,
                                     Ada.Strings.Maps.Constants.Upper_Case_Map);
  begin
    --  We enumerate all PIDs on the system, obtain the name for each
    --  process, and compare it with the requested process name.
    Valid := False;
    for i in PIDs'Range loop
      if Ada.Strings.Fixed.Translate (Get_Process_Name (PIDs (i)),
                                      Ada.Strings.Maps.Constants.Upper_Case_Map)
         = Upper_Case_Name
        then
          Result := PIDs (i); Valid := True; exit;
      end if;
    end loop;
    if not Valid then
      Ada.Exceptions.Raise_Exception(Find_Function_Error'Identity,
                                     "Process "&PName&" not found.");
    end if;
    return Result;
  end Find;

  ----------
  -- List --
  ----------

  function List (PName : in String) return Process_ID is
    Valid : Boolean;
    Result : Process_ID;
    PIDs : constant Process_ID_Array := Find_All_Process_IDs;

    Find_Function_Error : exception;

    Upper_Case_Name : constant String
      := Ada.Strings.Fixed.Translate(PName,
                                     Ada.Strings.Maps.Constants.Upper_Case_Map);
  begin
    --  We enumerate all PIDs on the system, obtain the name for each
    --  process, and compare it with the requested process name.
    Valid := False;
    for i in PIDs'Range loop
      if Ada.Strings.Fixed.Translate (Get_Process_Name (PIDs (i)),
                                      Ada.Strings.Maps.Constants.Upper_Case_Map)
         = Upper_Case_Name
        then
          Result := PIDs (i); Valid := True; exit;
      end if;
    end loop;
    if not Valid then
      Ada.Exceptions.Raise_Exception(Find_Function_Error'Identity,
                                     "Process "&PName&" not found.");
    end if;
    return Result;
  end List;

  ----------------------
  -- Find_from_Window --
  ----------------------

  function Find_from_Window (WName : in String) return Process_ID is
  begin
    return Get_Window_Thread_Process_ID(Find_Window(WName));
  end Find_from_Window;

  ----------
  -- Open --
  ----------

  function Open (ID : in Process_ID) return Handle is
  begin
    return Open_Process(ID);
  end Open;

  -----------------
  -- Launch_Open --
  -----------------

  function Launch_Open (Path : in String) return Handle is
  begin
    return Open_Process(Launch(Path));
  end Launch_Open;

  ---------------
  -- Find_Open --
  ---------------

  function Find_Open (PName : in String) return Handle is
    ID    : Process_ID;
    Valid : Boolean;
  begin
    Find(PName, ID, Valid);
    return Open_Process(ID);
  end Find_Open;

  ---------------------------
  -- Find_from_Window_Open --
  ---------------------------

  function Find_from_Window_Open (WName : in String) return Handle is
  begin
    return Open_Process(Get_Window_Thread_Process_ID(Find_Window(WName)));
  end Find_from_Window_Open;

  -----------
  -- Close --
  -----------

  procedure Close (H : in Handle) is
  begin
    Close_Handle(H);
  end Close;

  --------------------------
  -- Find_All_Process_IDs --
  --------------------------

  function Find_All_Process_IDs return Process_ID_Array is
    use Interfaces.C;
     --  Fetch an array of process IDs of a particular length.

     function Get_Array
       (Length : Positive;
        Actual_Length : access Positive)
       return Process_ID_Array
     is
        Data : Process_ID_Array (1 .. Length);
        Returned_Bytes : aliased DWord;

     begin
        if EnumProcesses(Data'Address, Data'Length * DWord'Size / 8,
                         Returned_Bytes'Access) = 0
        then
           raise Program_Error;
        else
           Actual_Length.all
             := Positive (Returned_Bytes / (DWord'Size / 8));
           if Actual_Length.all > Data'Length then
              return Data;
           else
              return Data (1 .. Actual_Length.all);
           end if;
        end if;
     end Get_Array;

     Current_Length : Positive := 200;
     Actual_Length : aliased Positive;

  begin                             --  Get_Process_IDs
     loop
        declare
           Data : Process_ID_Array := Get_Array (Current_Length,
                                                 Actual_Length'Access);

        begin
           if Data'Length = Actual_Length then
              return Data;
           end if;
           Current_Length := Actual_Length;
        end;
     end loop;
  end Find_All_Process_IDs;

  --------------
  -- Find_All --
  --------------

  function Find_All (Name : in String) return Process_ID_Array is
     PIDs : constant Process_ID_Array := Find_All_Process_IDs;
     Result : Process_ID_Array (PIDs'Range);
     Result_Position : Positive := Result'First;

     Upper_Case_Name : constant String
       := Ada.Strings.Fixed.Translate (Name, Ada.Strings.Maps.Constants.Upper_Case_Map);
  begin
     --  We enumerate all PIDs on the system, obtain the name for each
     --  process, and compare it with the requested process name.

     for J in PIDs'Range loop
      if Ada.Strings.Fixed.Translate (Get_Process_Name (PIDs (J)),
                                      Ada.Strings.Maps.Constants.Upper_Case_Map)
        = Upper_Case_Name
        then
          Result (Result_Position) := PIDs (J);
          Result_Position := Result_Position + 1;
      end if;
    end loop;
    return Result (Result'First .. Result_Position - 1);
  end Find_All;

  ---------------------
  -- Get_Object_Name --
  ---------------------

  function Get_Object_Name (Object : Handle) return Wide_String is
    use Interfaces.C;
    Get_Object_Name_Error : exception;
    Object_Name : aliased Object_Name_Record;
  begin
    if NtQueryObject (Object, ObjectNameInformation,
                      Object_Name'Address, Object_Name'Size / 8,
                      null) >= 0
      then
        if PWCH_equals(Object_Name.Buffer, null) then
          return "";
        end if;
      declare
        Length : Natural
          := Natural(lstrlenW(Object_Name));
        subtype Constrained_String is  Wide_String (1 .. Length);
        Result : Constrained_String;
        for Result'Address use Object_Name.Buffer.all'Address;
        --  The Result object is placed at the location the name was
        --  copied to.
      begin
        return Result;
      end;
    else
      Ada.Exceptions.Raise_Exception(Get_Object_Name_Error'Identity,
                                     "Object not found.");
    end if;
  end Get_Object_Name;

  ----------------------
  -- Get_Process_Name --
  ----------------------

  function Get_Process_Name (PID : Process_ID) return String is
    use Interfaces.C;
    Process : Handle;
    Data    : aliased HInstance;
    Needed  : aliased DWord;
  begin
    Process := Open_Process_Query(PID);
    if Address_equals(Process, System.Null_Address) then
      --Put_Line("It's null");
      return "";
    end if;
    --  The process name is the base name (i.e. the path name minus the
    --  directory component) of the first module loaded in the process.
    if EnumProcessModules (Process, Data'Access, Data'Size / 8,
                           Needed'Access) = 0
    then
      Close_Handle (Process);
      --Put_Line("EnumProcessModules failed");
      return "";
    else
      declare
        Name : String := Get_Module_Base_Name (Process, Data);
      begin
        --Put_Line("Returning string");
        Close_Handle (Process);
        return Name;
      end;
    end if;
  end Get_Process_Name;

  ---------------------------
  --  Get_Module_Base_Name --
  ---------------------------

  function Get_Module_Base_Name(Process : Handle;
                                Module  : HModule) return String is
    use Interfaces.C;
    Process_Name : aliased String (1 .. Max_Path);
    Process_Name_Alias : aliased Chara;
    for Process_Name_Alias'Address use Process_Name'Address;
    Length : DWord;
  begin
    Length := GetModuleBaseName (Process, Module,
                                 Process_Name_Alias'Unchecked_Access,
                                 Process_Name'Length);
    if Length = 0 then
      raise Program_Error;
    end if;
    return Process_Name (1 .. Positive (Length));
  end Get_Module_Base_Name;

  ------------------------------
  --  Find_All_Module_Entries --
  ------------------------------

  function Find_All_Module_Entries (PID : Process_ID)
                                    return Module_Entry_Array is
    MEArray : Module_Entry_Array(1..300);
    h : handle;
    i : integer;

    function List_Next return boolean is
    begin
      MEArray(i) := Module32_Next(h);
      return True;
    exception
      when Win32_Error => return false;
    end List_Next;

  begin
    H := Create_Toolhelp32_Snapshot(PID, TH32CS_SNAPMODULE);
    MEArray(1) := Module32_First(h);
    i := 2;
    while List_Next and i <= MEArray'length loop
      i:= i+1;
    end loop;
    Close(h);
    Return MEArray(1..i-1);
  end Find_All_Module_Entries;

  -----------------
  -- Find_Module --
  -----------------

  function Find_Module(query : string; on : Module_Entry_Array)
                       return MODULEENTRY32 is
    use Interfaces.C;
    Find_Module_Error : exception;
    i : integer;
  begin
    i := 1;
    while To_Ada(Win32.To_C(on(i).szModule)) /= query and  i < on'length loop
      i := i+1;
    end loop;
    if To_Ada(Win32.To_C(on(i).szModule)) /= query then
      Ada.Exceptions.Raise_Exception(Find_Module_Error'Identity,
                                     "Module "&query&" not found.");
      return(on(on'first));
    else
      return on(i);
    end if;
  end Find_Module;

  -----------------------------
  -- Get_Module_Base_Address --
  -----------------------------

  function Get_Module_Base_Address(Module : string; Proc : Process_ID)
                                   return Address is
    function To_Address is new Ada.Unchecked_Conversion(PBYTE, Address);
  begin
    return
      To_Address(Find_Module(Module, Find_All_Module_Entries(Proc)).modBaseAddr);
  end Get_Module_Base_Address;

  function Get_Module_Info (Module : string; Proc : Process_ID)
                            return Module_Info is
    function To_Address is new Ada.Unchecked_Conversion(PBYTE, Address);
    Full_Info : MODULEENTRY32;
  begin
    Full_Info := Find_Module(Module, Find_All_Module_Entries(Proc));
    return  (To_Address(Full_Info.modBaseAddr), Integer(Full_Info.modBaseSize));
  end Get_Module_Info;
end win32api_interface.process.helper;

